Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue43/delay/HVDll.pas

Pascal/Delphi Source File | 1999-01-28 | 11.9 KB | 458 lines

unit HVDll;
//
// Support for DelayLoading of DLLs ß la VC++6.0
// Written by Hallvard Vassbotn ([e-mail]), January 1999
//
interface

uses
  Windows,
  Classes,
  SysUtils,
  HVHeaps;

type
  // Structures to keep the address of function variables and name/id pairs
  PPointer = ^pointer;
  PEntry = ^TEntry;
  TEntry = packed record
    Proc: PPointer;
    case integer of
      0 : (Name: PChar);
      1 : (ID  : Longint);
    end;
  PEntries = ^TEntries;
  TEntries = packed array[0..High(Word)-1] of TEntry;

  // Structures to generate the per-routine thunks
  PThunk = ^TThunk;
  TThunk = packed record
    CALL  : byte;
    OFFSET: integer;
  end;
  PThunks = ^TThunks;
  TThunks = packed array[0..High(Word)-1] of TThunk;

  // Structure to generate the per-DLL thunks
  TThunkHeader = packed record
    PUSH   : byte;
    VALUE  : pointer;
    JMP    : byte;
    OFFSET : integer;
  end;

  // The combined per-DLL and per-routine thunks
  PThunkingCode = ^TThunkingCode;
  TThunkingCode = packed record
    ThunkHeader : TThunkHeader;
    Thunks      : TThunks;
  end;

  // The base class that provides DelayLoad capability
  TDll = class(TObject)
  private
    FEntries  : PEntries;
    FThunkingCode: PThunkingCode;
    FCount    : integer;
    FFullPath : string;
    FHandle   : HMODULE;
    function GetHandle: HMODULE;
    procedure SetFullPath(const Value: string);
    function GetProcs(Index: integer): pointer;
    procedure SetProcs(Index: integer; Value: pointer);
    function GetAvailable: boolean;
    function GetLoaded: boolean;
    function LoadProcAddrFromIndex(Index: integer; var Addr: pointer): boolean;
    procedure ActivateThunks;
    function GetEntryName(Index: integer): string;
  protected
    function LoadHandle: HMODULE; virtual;
    class procedure Error(const Msg: string; Args: array of const);
    procedure CreateThunks;
    procedure DestroyThunks;
    function HasThunk(Thunk: PThunk): boolean;
    function GetProcAddrFromIndex(Index: integer): pointer;
    function DelayLoadFromThunk(Thunk: PThunk): pointer; register;
    function DelayLoadIndex(Index: integer): pointer;
    function GetIndexFromThunk(Thunk: PThunk): integer;
    function GetIndexFromProc(Proc: PPointer): integer;
    function ValidIndex(Index: integer): boolean;
    procedure CheckIndex(Index: integer);
    property Procs[Index: integer]: pointer read GetProcs write SetProcs;
  public
    constructor Create(const DllName: string; const Entries: array of TEntry);
    destructor Destroy; override;
    procedure Load;
    procedure Unload;
    function HasRoutine(Proc: PPointer): boolean;
    function HookRoutine(Proc: PPointer; HookProc: Pointer; var OrgProc{: Pointer}): boolean;
    function UnHookRoutine(Proc: PPointer; var OrgProc{: Pointer}): boolean;
    property FullPath: string read FFullPath write SetFullPath;
    property Handle: HMODULE read GetHandle;
    property Loaded: boolean read GetLoaded;
    property Available: boolean read GetAvailable;
    property Count: integer read FCount;
    property EntryName[Index: integer]: string read GetEntryName;
  end;

  // The class that keeps a list of all created TDll instances in one place
  TDllNotifyAction = (daLoadedDll, daUnloadedDll, daLinkedRoutine);
  TDllNotifyEvent = procedure(Sender: TDll; Action: TDllNotifyAction; Index: integer) of object;
  TDlls = class(TList)
  private
    FCodeHeap: TCodeHeap;
    FOnDllNotify: TDllNotifyEvent;
    function GetDlls(Index: integer): TDll;
  protected
    procedure DllNotify(Sender: TDll; Action: TDllNotifyAction; Index: integer);
    property CodeHeap: TCodeHeap read FCodeHeap;
  public
    constructor Create;
    destructor Destroy; override;
    property Dlls[Index: integer]: TDll read GetDlls; default;
    property OnDllNotify: TDllNotifyEvent read FOnDllNotify write FOnDllNotify;
  end;

  EDllError = class(Exception);

var
  Dlls: TDlls;

implementation

{$IFDEF VER90}
const
{$ELSE}
resourcestring
{$ENDIF}
  SIndexOutOfRange      = 'DLL-entry index out of range (%d)';
  SOrdinal              = 'ordinal #';
  SCannotLoadLibrary    = 'Could not find the library: "%s"'#13#10'(%s)';
  SCannotGetProcAddress = 'Could not find the routine "%s" in the library "%s"'#13#10'(%s)';
  SCannotFindThunk      = 'Could not find the TDll object corresponding to the thunk address %p';

{ Helper routines }

function EntryToString(const Entry: TEntry): string;
begin
  if Hi(Entry.ID) <> 0
  then Result := string(Entry.Name)
  else Result := SOrdinal+IntToStr(Entry.ID);
end;

procedure ThunkingTarget;
const
  TThunkSize = SizeOf(TThunk);
asm
  // Save register-based parameters
  PUSH    EAX
  PUSH    EDX
  PUSH    ECX
{ Stack layout at this point:
  24 [Stack based parameters]
  20 [User code RetAdr]
  16 [Thunk Ret-Adr]
  12 [Self]
   8 [EAX]
   4 [EDX]
   0 [ECX] <-ESP}
  // Get the caller's return address (i.e. one of the thunks)
  MOV     EAX, [ESP+12]   // Self
  MOV     EDX, [ESP+16]   // Thunk
  // The return address is just after the thunk that
  // called us, so go back one step
  SUB     EDX, TYPE TThunk // Using SizeOf(TThunk) here does not work. BASM bug?
  // Do the rest in Pascal
  CALL    TDll.DelayLoadFromThunk{(Self, Thunk);}
  // Now patch the return address on the stack so that we "return" to the DLL routine
  MOV     [ESP+16], EAX
  // Restore register-based parameters
  POP     ECX
  POP     EDX
  POP     EAX
  // Remove the Self pointer!
  ADD        ESP,  4
  // "RETurn" to the DLL!
end;

{ TDll }

constructor TDll.Create(const DllName: string; const Entries: array of TEntry);
begin
  inherited Create;
  FFullPath := DllName;
  FEntries  := @Entries;
  FCount    := High(Entries) - Low(Entries) + 1;
  CreateThunks;
  ActivateThunks;
  Dlls.Add(Self);
end;

destructor TDll.Destroy;
begin
  Dlls.Remove(Self);
  Unload;
  DestroyThunks;
  inherited Destroy;
end;

procedure TDll.CreateThunks;
const
  CallInstruction = $E8;
  PushInstruction = $68;
  JumpInstruction = $E9;
var
  i : integer;
begin
  // Get a memory block large enough for the thunks
  Dlls.CodeHeap.GetMem(FThunkingCode, SizeOf(TThunkHeader) + SizeOf(TThunk) * Count);

  // Generate some machine code in the thunks
  with FThunkingCode^, ThunkHeader do
  begin
    // The per-Dll thunk does this:
    // PUSH    Self
    // JMP     ThunkingTarget
    PUSH   := PushInstruction;
    VALUE  := Self;
    JMP    := JumpInstruction;
    OFFSET := PChar(@ThunkingTarget) - PChar(@Thunks[0]);
    for i := 0 to Count-1 do
      with Thunks[i] do
      begin
        // The per-entry thunk does this:
        // CALL @ThunkingCode^.ThunkHeader
        CALL   := CallInstruction;
        OFFSET := PChar(@FThunkingCode^.ThunkHeader) - PChar(@Thunks[i+1]);
      end;
  end;
end;

procedure TDll.DestroyThunks;
begin
  if Assigned(FThunkingCode) then
  begin
    Dlls.CodeHeap.FreeMem(FThunkingCode);
    FThunkingCode := nil;
  end;
end;

function TDll.DelayLoadFromThunk(Thunk: PThunk): pointer; register;
begin
  Result := DelayLoadIndex(GetIndexFromThunk(Thunk));
end;

function TDll.DelayLoadIndex(Index: integer): pointer;
begin
  Result := GetProcAddrFromIndex(Index);
  FEntries^[Index].Proc^ := Result;
end;

class procedure TDll.Error(const Msg: string; Args: array of const);
begin
  raise EDllError.CreateFmt(Msg, Args);
end;

function TDll.LoadHandle: HMODULE;
begin
  if FHandle = 0 then
  begin
    FHandle := Windows.LoadLibrary(PChar(FullPath));
    if FHandle <> 0 then
      Dlls.DllNotify(Self, daLoadedDll, -1);
  end;
  Result := FHandle;
end;

function TDll.GetHandle: HMODULE;
begin
  Result := FHandle;
  if Result = 0 then
  begin
    Result := LoadHandle;
    if Result = 0 then
      Error(SCannotLoadLibrary, [FullPath, SysErrorMessage(GetLastError)]);
  end;
end;

function TDll.GetIndexFromThunk(Thunk: PThunk): integer;
begin
  // We calculate the thunk index by subtracting the start of the array
  // and dividing by the size of the array elements
  Result := (PChar(Thunk) - PChar(@FThunkingCode^.Thunks[0])) div SizeOf(TThunk);
end;

function TDll.LoadProcAddrFromIndex(Index: integer; var Addr: pointer): boolean;
begin
  Result := ValidIndex(Index);
  if Result then
  begin
    Addr := Windows.GetProcAddress(Handle, FEntries^[Index].Name);
    Result := Assigned(Addr);
    if Result then
      Dlls.DllNotify(Self, daLinkedRoutine, Index);
  end;
end;

function TDll.GetProcAddrFromIndex(Index: integer): pointer;
begin
  if not LoadProcAddrFromIndex(Index, Result) then
    Error(SCannotGetProcAddress, [EntryName[Index], FullPath, SysErrorMessage(GetLastError)]);
end;

function TDll.HasThunk(Thunk: PThunk): boolean;
begin
  // The thunk belongs to us if its address is in the thunk array
  Result := (PChar(Thunk) >= PChar(@FThunkingCode^.Thunks[0])) and
            (PChar(Thunk) <= PChar(@FThunkingCode^.Thunks[Count-1]));
end;

procedure TDll.Load;
var
  i : integer;
begin
  for i := 0 to Count-1 do
    DelayLoadIndex(i);
end;

procedure TDll.SetFullPath(const Value: string);
begin
  if CompareText(FFullPath, Value) <> 0 then
  begin
    Unload;
    FFullPath := Value;
  end;
end;

function TDll.GetEntryName(Index: integer): string;
begin
  if ValidIndex(Index)
  then Result := EntryToString(FEntries^[Index])
  else Result := Format(SIndexOutOfRange, [Index]);
end;

procedure TDll.ActivateThunks;
// Patch the procedure variables to point to the generated thunks
var
  i : integer;
begin
  for i := 0 to Count-1 do
    FEntries^[i].Proc^ := @FThunkingCode^.Thunks[i];
end;

procedure TDll.Unload;
begin
  ActivateThunks;
  if FHandle <> 0 then
  begin
    FreeLibrary(FHandle);
    Dlls.DllNotify(Self, daUnloadedDll, -1);
    FHandle := 0;
  end;
end;

function TDll.ValidIndex(Index: integer): boolean;
begin
  Result := (Index >= 0) and (Index <= Count-1);
end;

procedure TDll.CheckIndex(Index: integer);
begin
  if not ValidIndex(Index) then
    Error(SIndexOutOfRange, [Index]);
end;

function TDll.GetProcs(Index: integer): pointer;
begin
  CheckIndex(Index);
  Result := FEntries^[Index].Proc^;
end;

procedure TDll.SetProcs(Index: integer; Value: pointer);
begin
  CheckIndex(Index);
  FEntries^[Index].Proc^ := Value;
end;

function TDll.GetAvailable: boolean;
begin
  Result := (LoadHandle <> 0);
end;

function TDll.GetLoaded: boolean;
begin
  Result := (FHandle <> 0);
end;

function TDll.GetIndexFromProc(Proc: PPointer): integer;
begin
  for Result := 0 to Count-1 do
    if FEntries^[Result].Proc = Proc then
      Exit;
  Result := -1;
end;

function TDll.HasRoutine(Proc: PPointer): boolean;
begin
  Result := Available and
            ((not HasThunk(Proc^)) or
              LoadProcAddrFromIndex(GetIndexFromProc(Proc), Proc^));
end;

function TDll.HookRoutine(Proc: PPointer; HookProc: Pointer; var OrgProc{: Pointer}): boolean;
begin
  Result := HasRoutine(Proc);
  if Result then
  begin
    Pointer(OrgProc) := Proc^;
    Proc^   := HookProc;
  end;
end;

function TDll.UnHookRoutine(Proc: PPointer; var OrgProc{: Pointer}): boolean;
begin
  Result := Assigned(Pointer(OrgProc));
  if Result then
  begin
    Proc^ := Pointer(OrgProc);
    Pointer(OrgProc) := nil;
  end;
end;

{ TDlls }

constructor TDlls.Create;
begin
  inherited Create;
  FCodeHeap := TCodeHeap.Create;
end;

destructor TDlls.Destroy;
var
  i : integer;
begin
  for i := Count-1 downto 0 do
    Dlls[i].Free;
  FCodeHeap.Free;
  FCodeHeap := nil;
  inherited Destroy;
end;

procedure TDlls.DllNotify(Sender: TDll; Action: TDllNotifyAction; Index: integer);
begin
  if Assigned(FOnDllNotify) then
    FOnDllNotify(Sender, Action, Index);
end;

function TDlls.GetDlls(Index: integer): TDll;
begin
  Result := TDll(Items[Index]);
end;

initialization
  Dlls := TDlls.Create;
finalization
  Dlls.Free;
  Dlls := nil;
end.